home *** CD-ROM | disk | FTP | other *** search
/ 17 Bit Software 5: The Fifth Dimension / 17 Bit - The Fifth Dimension (1995)(17 Bit Software)[!].iso / files / 3851.dms / 3851.adf / ScionARexx.lha / PrintPedigree.rexx < prev    next >
OS/2 REXX Batch file  |  1995-06-01  |  21KB  |  724 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * $VER: PrintPedigree 2.00 (2 Feb 1995)
  4.  *                                                                          *
  5.  *                      Written by Freddy Ariës                             *
  6.  *                                                                          *
  7.  * Output options:                                                          *
  8.  *  1. Pedigree Chart - male ancestor line only [Dutch: stamreeks]          *
  9.  *  2. Pedigree Chart - all ancestors, no siblings [Dutch: kwartierstaat]   *
  10.  *  3. Pedigree Chart - all ancestors, only siblings of last generation     *
  11.  *  4. Pedigree Chart - all ancestors, all siblings                         *
  12.  *                                                                          *
  13.  * This version uses (by default) the rexxreqtools.library (which requires  *
  14.  * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
  15.  * If you do not have these, you need to supply the NOREQ argument (for     *
  16.  * Shell output), or the QUIET argument (for no output at all).             *
  17.  *                                                                          *
  18.  * As of v2 of this script, and Scion V4, the current person on Scion's     *
  19.  * Personal Window will be used to determine where the search starts.       *
  20.  * Scion 3.13 can still be used, though, in which case the user will be     *
  21.  * asked at which IRN he wants to start.                                    *
  22.  *                                                                          *
  23.  * TO DO (mostly low priority, unless someone really wants this):           *
  24.  *  - count the number of lines output and give a formfeed after a certain  *
  25.  *    number (ie. skip page breaks)                                         *
  26.  *  - Add a menu option for the maximum number of generations to print      *
  27.  *  - allow user to specify if he wants burial data printed, occupation,    *
  28.  *    comments, references fields, ....                                     *
  29.  *  - option: include empty fields                                          *
  30.  *  - find a good way to handle sex-fields with value '?'                   *
  31.  *                                                                          *
  32.  * Known Bugs/Problems:                                                     *
  33.  *  - This script is dog slow for large databases (ie. more than, say, 10   *
  34.  *    generations), even on Amigas with a Turboboard!                       *
  35.  *  - Incorrect results may be returned when there are persons in the       *
  36.  *    database whose sex-field has value '?'                                *
  37.  *                                                                          *
  38.  ****************************************************************************/
  39.  
  40. options results
  41. arg prtin outname noirn mgen outval
  42.  
  43. versionstr = "2.00"
  44. usereq = 1; /* change this to 0 if you don't want to use reqtools */
  45. outp = 1; useirn = 1; prtdev = stdout; prtopt = 0
  46. plwidth = 78;  /* linewidth of the printer */
  47. NL = '0A'x
  48. PSCR = 'SCIONGEN'; /* public screen to open the requesters on */
  49.  
  50. numpers = 1
  51.  
  52. DbtGen = 12; /* Suggested value for 68000: 10, with Turbo-boards: 12 */
  53. /* From this generation onwards, every generation needs a confirm */
  54. /* Note: 12 generations means (at most) 4096 persons!!! */
  55.  
  56. signal on IOERR
  57.  
  58. /* parse command line options, to allow calling the script automatically,
  59.  * eg. from a function key
  60.  */
  61.  
  62. do while prtin = '?'
  63.   Tell("NUMOPT/A/N,OUTFILE/A,NOIRN/S,MAXGEN/N,QUIET/S,NOREQ/S: ")
  64.   pull prtin outname noirn mgen outval
  65. end
  66.  
  67. ParseArguments()
  68.  
  69. if usereq & ~show('l','rexxreqtools.library') then do
  70.   if exists('libs:rexxreqtools.library') then
  71.     call addlib('rexxreqtools.library',0,-30,0)
  72.   else do
  73.     usereq = 0; outp = 1
  74.     Tell("Unable to open rexxreqtools.library - using text output")
  75.   end
  76. end
  77.  
  78. /* These first few lines were stolen from Peter Billings - thanks Peter ;-) */
  79. if ~show('P','SCIONGEN') then do
  80.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  81.     'database is not available. Please start the' || NL ||,
  82.     'SCION program BEFORE using this script!')
  83. end
  84.  
  85. myport = "SCIONGEN"
  86. address value myport
  87. GETDBNAME
  88. dbname = upper(RESULT)
  89. GETPROGVERSION
  90. progvers = RESULT
  91.  
  92. if progvers >= 4 then do
  93.   GETCURRENTIRN
  94.   irn = RESULT
  95. end
  96.  
  97. if outp & ~usereq then do
  98.   Tell("*** PrintPedigree version "||versionstr||" ***")
  99.   Tell("***       by Freddy Ariës      ***")
  100.   Tell("Current database: "||dbname||NL)
  101. end
  102. if prtopt = 0 then do
  103.   /* No use in asking for input if we're not allowed to output anything */
  104.   if usereq then do
  105.     prtopt = rtezrequest('Current Scion database: '||dbname||NL||,
  106.       NL||'Please make your choice: '||,
  107.       NL||'1. Pedigree Chart - male ancestor line only'||,
  108.       NL||'2. Pedigree Chart - all ancestors, no siblings'||,
  109.       NL||'3. Pedigree Chart - all ancestors, only last generation siblings'||,
  110.       NL||'4. Pedigree Chart - all ancestors, all siblings'||,
  111.       '',' _1 | _2 | _3 | _4 |E_xit','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
  112.     if prtopt = 0 then
  113.       EXIT
  114.  
  115.     if progvers < 4 then do
  116.       irn = rtgetlong(,'Enter the IRN of the person whose'||,
  117.             NL||'ancestors you want to print: '||,
  118.             NL,'Input Request:','_Continue','rt_pubscrname = '||PSCR)
  119.       if irn = '' then
  120.         EXIT
  121.       irn = abs(irn)
  122.     end
  123.  
  124.     useirn = rtezrequest('Do you want to output the IRNs'||,
  125.               NL||'(the record numbers) as well?'||,
  126.               '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  127.   end
  128.   else do
  129.     Tell("1. Pedigree Chart - male ancestor line only")
  130.     Tell("2. Pedigree Chart - all ancestors, no siblings")
  131.     Tell("3. Pedigree Chart - all ancestors, only siblings of last generation")
  132.     Tell("4. Pedigree Chart - all ancestors, all siblings")
  133.     TellNN("Your choice: ")
  134.     pull prtopt
  135.     prtopt = CheckAnswer(prtopt)
  136.  
  137.     if progvers < 4 then do
  138.       TellNN("Enter the IRN of the person whose ancestors you want to print: ")
  139.       pull irn
  140.     end
  141.  
  142.     TellNN("Do you want to output the IRN (numbers) as well (y/n)? ")
  143.     pull instr
  144.     Tell("")
  145.     if left(instr, 1) = "Y" | left(inp, 1) = "y" then useirn = 1
  146.     else useirn = 0
  147.   end
  148. end
  149.  
  150. if progvers < 4 then do
  151.   irn = CheckIRN(irn)
  152. end
  153.  
  154. EXISTPERSON irn
  155. if RESULT ~= 'YES' then
  156. do
  157.   if progvers >= 4 then
  158.     TermError("Unable to determine current person in the database.")
  159.   else
  160.     TermError("No person with IRN "||irn||" in the current database.")
  161. end
  162.  
  163. if outp then do
  164.   pname = GetNameStr(irn, 0)
  165.   if usereq then do
  166.     valcont = rtezrequest('The selected person is: '||NL||pname||'.'||,
  167.       NL||'Continue?','_Continue| _Abort','PrintPedigree Request:','rt_pubscrname = '||PSCR)
  168.     if valcont = 0 then
  169.       EXIT
  170.   end
  171.   else do
  172.     TellNN("Current person is "||pname||". Continue? (y/n) ")
  173.     pull valcont
  174.     if left(valcont, 1) ~= 'Y' then
  175.       TermError("Ok.")
  176.   end
  177. end
  178.  
  179. if outp & outname = "" then do
  180.   if usereq then do
  181.     odev = rtezrequest('Current Scion database: '||dbname||,
  182.       NL||'Where should the output be sent to?'||,
  183.       NL,' _File |_Printer|_Screen|_Nowhere','PrintPedigree v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
  184.     select
  185.       when odev = 1 then do
  186.         /* We need a file requester for further data */
  187.         dblen = length(dbname)
  188.         if dblen>6 & right(dbname, 6)=".SCION" then
  189.           dbname=left(dbname, dblen - 6)
  190.         outname = rtfilerequest(,dbname||'.PED','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
  191.         if outname = '' then
  192.           outname = dbname||'.PED'
  193.       end
  194.       when odev = 2 then
  195.         outname = 'PRT:'
  196.       when odev = 3 then
  197.         outname = 'STDOUT'
  198.       otherwise
  199.         EXIT
  200.         /* You selected 'Nowhere' */
  201.     end
  202.   end
  203.   else do
  204.     Tell("Enter output file (filename with complete path, or PRT: for printer,")
  205.     TellNN("or STDOUT for screen): ")
  206.     pull outname
  207.     if outname = "" then
  208.       outname = "STDOUT"
  209.   end
  210. end
  211.  
  212. /* Anyone know a better way to translate numbers into Roman? */
  213. GenerationS.1 = "I II III IV V VI VII VIII IX X XI XII XIII XIV XV XVI XVII XVIII XIX XX"
  214. GenerationS.2 = "XXI XXII XXIII XXIV XXV XXVI XXVII XXVIII XXIX XXX XXXI XXXII XXXIII XXXIV XXXV XXXVI XXXVII XXXVIII IXL XL"
  215.  
  216. /* Printer Codes (some of which are currently unused): */
  217. ESC = '1B'x
  218. prtinit = ESC||"#1";     /* ESC#1 initialize      */
  219. prtundon = ESC||"[4m";   /* ESC[4m underline on   */
  220. prtundoff = ESC||"[24m"; /* ESC[24m underline off */
  221. prtdson = ESC||"[1m";    /* ESC[1m boldface on    */
  222. prtdsoff = ESC||"[22m";  /* ESC[22m boldface off  */
  223. prtnlqon = ESC||"[2"||'22'x||"z";  /* ESC[2"z NLQ on  */
  224. prtnlqoff = ESC||"[1"||'22'x||"z"; /* ESC[1"z NLQ off */
  225.  
  226. if ~usereq then
  227.   Tell("Building ancestor table...")
  228.  
  229. currgen = 1
  230. GENTREE.1 = irn
  231.  
  232. /* Build the ancestor table */
  233. do until ~foundone
  234.   foundone = 0
  235.   currgen = currgen + 1
  236.   numpers = 2 * numpers
  237.   /* = 2 ** (currgen - 1) */
  238.   if currgen <= MaxGens then
  239.   do
  240.     if currgen > DbtGen then
  241.     do
  242.       if usereq then
  243.       do
  244.         docont = rtezrequest('Also parse generation '||currgen||' ?'||,
  245.               NL||'(this may take *very* long!)'||,
  246.               '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  247.       end
  248.       else
  249.       do
  250.         Tell("Also parse generation '||currgen||' ?' (this may take *very* long!)")
  251.         pull inp
  252.         Tell("")
  253.         if left(inp, 1) = "Y" | left(inp, 1) = "y" then docont = 1
  254.         else docont = 0
  255.  
  256.       end
  257.     end
  258.     else docont = 1
  259.  
  260.     if docont then
  261.     do
  262.       if prtopt = 1 then
  263.         endnum = numpers+1
  264.         /* no use to build the entire table, if we need only this little */
  265.       else
  266.         endnum = 2*numpers-1
  267.       /*
  268.        * TO DO: at the moment, all the numbers are parsed, even if there
  269.        *          is only one family group with ancestors in this generation
  270.        *        This means that thousands of fields may be checked, to find
  271.        *        two persons. This also makes the program dog slow!
  272.        *        I must make a better method to do this.
  273.        */
  274.       do ct = numpers to endnum by 2
  275.         ct1 = ct % 2
  276.         irn = GENTREE.ct1
  277.         ct1 = ct + 1
  278.         GENTREE.ct = 0
  279.         GENTREE.ct1 = 0
  280.         if irn ~= 0 then do
  281.           GETPARENTS irn
  282.           fgrn = RESULT
  283.           EXISTFAMILY fgrn
  284.           if RESULT = 'YES' then do
  285.             foundone = 1
  286.             GetParentsIRN(fgrn, ct, ct1)
  287.           end
  288.         end
  289.       end
  290.     end
  291.   end
  292.   else do
  293.     if usereq then
  294.       rtezrequest('Maximum number of'||NL||'generations reached.'||NL||,
  295.     NL||'Output truncated','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
  296.     else
  297.      Tell("Maximum number of generations reached. Output may be truncated.")
  298.   end
  299. end
  300. numgens = currgen - 1
  301.  
  302. /* Now print all the ancestors */
  303. if ~usereq then
  304.   Tell("Printing data...")
  305.  
  306. OpenPrinter()
  307.  
  308. if prtopt = 1 then do
  309.   /* print only male ancestors */
  310.   fill = 7
  311.   np = numpers%2
  312.   currgen = 1
  313.   do while np > 1
  314.     g1 = GetGenStr(currgen, fill)
  315.     ct1 = np + 1
  316.     ct2 = ct % 2
  317.     /* get the husband's data */
  318.     g1 = g1||GetPersonStr(GENTREE.np)
  319.     m1 = GetMarriageStr(GENTREE.ct2)
  320.     if m1 ~= "" then
  321.       m1 = g1||", m: "||m1
  322.     else m1 = g1
  323.     g1 = copies(' ',fill)
  324.     PrintLines(m1, fill)
  325.     /* get the wife's data */
  326.     m1 = g1||GetPersonStr(GENTREE.ct1)
  327.     PrintLines(m1, fill)
  328.     PrintLF()  
  329.     currgen = currgen + 1
  330.     np = np % 2
  331.   end
  332.   g1 = GetGenStr(currgen, fill)||GetPersonStr(GENTREE.np)
  333.   g1 = g1||GetMarriages(GENTREE.np)
  334.   PrintLines(g1, fill)
  335.   PrintLF()  
  336. end
  337. else do
  338.   /* print all */
  339.   currgen = currgen - 1
  340.   fill = 6
  341.  
  342.   g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth-1)
  343.   PrintLines(g1, fill)
  344.   g1 = "1.    "||GetPersonStr(GENTREE.1)
  345.   g1 = g1||GetMarriages(GENTREE.1)
  346.   PrintLines(g1, fill)
  347.   if prtopt > 2 then
  348.     PrintSiblings(GENTREE.1, 1)
  349.   PrintLF()  
  350.  
  351.   np = 2
  352.   currgen = currgen - 1
  353.   do while np < numpers
  354.     g1 = center("Generation: "||GetGenStr(currgen, fill), plwidth)
  355.     PrintLines(g1, fill)
  356.     endnum = 2*np-1
  357.     do ct = np to endnum by 2
  358.       ct1 = ct + 1
  359.       ct2 = ct % 2
  360.       /* print the principal data */
  361.       if GENTREE.ct ~= 0 then do
  362.         g1 = left(ct||".    ",fill)||GetPersonStr(GENTREE.ct)
  363.         m1 = GetMarriageStr(GENTREE.ct2)
  364.         if m1 ~= "" then
  365.           m1 = g1||", m: "||m1
  366.         else m1 = g1
  367.         g1 = copies(' ',fill)
  368.         PrintLines(m1, fill)
  369.         if prtopt = 4 then
  370.           PrintSiblings(GENTREE.ct, ct)
  371.       end
  372.       /* print the spouse data */
  373.       if GENTREE.ct1 ~= 0 then do
  374.         m1 = left(ct1||".    ",fill)||GetPersonStr(GENTREE.ct1)
  375.         PrintLines(m1, fill)
  376.         if prtopt = 4 then
  377.           PrintSiblings(GENTREE.ct1, ct1)
  378.       end
  379.     end
  380.     PrintLF()  
  381.     currgen = currgen - 1
  382.     np = np * 2
  383.   end
  384. end
  385. if numgens = 1 then
  386.   PrintLines("No ancestors are recorded for this person.", 0)
  387.  
  388. if usereq then
  389.   rtezrequest('Output ready.','_Continue','PrintPedigree Message:','rt_pubscrname = '||PSCR)
  390. else
  391.   Tell("Done.")
  392.  
  393. writeln(prtdev, prtnlqoff); /* ESC[1"z NLQ off */
  394. close(prtdev)
  395. EXIT
  396.  
  397. /* Parse command line arguments and set the appropriate global variables */
  398. ParseArguments:
  399. if noirn = "NOIRN" then useirn = 0
  400. else if noirn = "QUIET" || noirn = "NOREQ" then do
  401.   outval = noirn
  402.   noirn = ""
  403. end
  404. else do
  405.   outval = mgen
  406.   mgen = noirn
  407.   noirn = ""
  408. end
  409. if mgen = "QUIET" || mgen = "NOREQ" then do
  410.   outval = mgen
  411.   mgen = ""
  412. end
  413.  
  414. MaxGens = 20
  415. /* due to the Roman numbers, we can't handle more than 40 */
  416. /* but due to speed limitations, I don't advise using more than 20 */
  417. if mgen ~= "" then do
  418.   if DATATYPE(mgen, 'w') & mgen > 0 & mgen < MaxGens then
  419.     MaxGens = mgen
  420. end
  421.  
  422. if outval = "QUIET" then do
  423.   usereq = 0
  424.   outp = 0
  425. end
  426. else if outval = "NOREQ" then
  427.   usereq = 0
  428.  
  429. /* if outname = "" then */
  430. /*  outname = "STDOUT"  */
  431.  
  432. if prtin = "" then do
  433.   prtopt = 0
  434.   if ~outp then TermError("Requires argument is missing.")
  435.     /* actually, with outp = 0, all it does is EXIT */
  436. end
  437. else do
  438.   prtopt = CheckAnswer(prtin)
  439.   /* Note that it was important to establish outp before calling these */
  440. end  
  441.  
  442. return 0
  443.  
  444. OpenPrinter:
  445. /* Open the printer device and print out a nice header */
  446. if outname = "STDOUT" then
  447.   prtdev = stdout
  448. else do
  449.   prtdev = "PRINTER"
  450.   if ~open(prtdev, outname, 'w') then
  451.     TermError("ERROR: Failed to open output file!")
  452. end
  453. writeln(prtdev, prtinit||prtnlqon)
  454. if prtopt = 1 then
  455.   prtstr = "PEDIGREE CHART - MALE ANCESTOR LINE ONLY"
  456. else if prtopt = 2 then
  457.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, NO SIBLINGS"
  458. else if prtopt = 3 then
  459.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, ONLY SIBLINGS OF LAST GENERATION"
  460. else
  461.   prtstr = "PEDIGREE CHART - ALL ANCESTORS, ALL SIBLINGS"
  462. prtstr = prtundon||prtdson||prtstr||prtdsoff||prtundoff
  463. writeln(prtdev, prtstr)
  464. prtstr = prtdson||"Report printed on: "||date()||prtdsoff
  465. writeln(prtdev, prtstr)
  466. prtstr = copies('=', plwidth)
  467. writeln(prtdev, prtstr)
  468. return 0
  469.  
  470. PrintLines: PROCEDURE EXPOSE prtdev plwidth prtopt
  471. parse arg ostr, fill
  472. /* TO DO:
  473.  * if there are control strings within ostr (like prtdson or prtdsoff)
  474.  * don't include them in the length count
  475.  */
  476. do while ostr ~= ""
  477.   nnl = plwidth+1
  478.   if length(ostr) > plwidth then do
  479.     do until pc = ' ' | nnl = 1
  480.       pc = substr(ostr, nnl, 1)
  481.       nnl = nnl - 1
  482.     end
  483.     if nnl = 1 then do
  484.       prtstr = left(ostr, plwidth)
  485.       ostr = delstr(ostr, 1, nnl)
  486.     end
  487.     else do
  488.       prtstr = left(ostr, nnl)
  489.       ostr = delstr(ostr, 1, nnl+1)
  490.     end
  491.   end
  492.   else do
  493.     prtstr = ostr
  494.     ostr = ""
  495.   end
  496.   writeln(prtdev, prtstr)
  497.   if ostr ~= "" then
  498.     ostr = copies(' ',fill)||ostr
  499. end
  500. return 0
  501.  
  502. PrintLF:
  503. writeln(prtdev, "")
  504. return 0
  505.  
  506. PrintSiblings: PROCEDURE EXPOSE prtdev plwidth prtopt useirn
  507. parse arg inum, prenum
  508. GETPARENTS inum
  509. famfgrn = RESULT
  510. EXISTFAMILY famfgrn
  511. if RESULT ~= 'YES' then return 0; /* no parents, then no siblings */
  512. ix = 0; chnum = 0
  513. do until ischld ~= 'YES'
  514.   GETCHILD famfgrn ix
  515.   prsn = RESULT
  516.   EXISTPERSON prsn
  517.   ischld = RESULT
  518.   if ischld = 'YES' & prsn ~= inum then do
  519.     chnum = chnum + 1
  520.     ostr = copies(' ',7)||prenum||D2C(chnum+96)". "||GetPersonStr(prsn)
  521.     PrintLines(ostr, 11)
  522.     if chnum = 26 then return 0; /* 'z': can't handle more than 26 children */
  523.   end
  524.   ix = ix + 1
  525. end
  526. return 0
  527.  
  528. GetGenStr: PROCEDURE EXPOSE prtopt GenerationS.
  529. parse arg gnum, fill
  530. if gnum <= 20 then
  531.   gstr = word(GenerationS.1, gnum)
  532. else if gnum <= 40 then
  533.   gstr = word(GenerationS.2, gnum)
  534. else
  535.   return ""
  536. if prtopt = 1 then gstr = left(gstr||".     ",fill)
  537. return gstr
  538.  
  539. GetPersonStr: PROCEDURE EXPOSE useirn
  540. parse arg irn
  541. if irn ~= 0 then do
  542.   nstr = GetNameStr(irn)
  543.   nstr = nstr||GetBirthStr(irn)
  544.   nstr = nstr||GetDeathStr(irn)
  545. end
  546. else
  547.   nstr = "UNKNOWN"
  548. return nstr
  549.  
  550. GetNameStr: PROCEDURE EXPOSE useirn
  551. parse arg gnum
  552. /* prtdson = '1B'x||"[1m";    * ESC[1m boldface on    */
  553. /* prtdsoff = '1B'x||"[22m";  * ESC[22m boldface off  */
  554. GETFIRSTNAME gnum
  555. name = RESULT
  556. if name ~= "" then name = name||" "
  557. GETLASTNAME gnum
  558. lname = RESULT
  559. if lname = "" then lname = "UNKNOWN"
  560. name = name||lname
  561. /* another option: name = name||prtdson||lname||prtdsoff
  562.  * Problem: see PrintLines
  563.  */
  564. if useirn then name = name||" ["gnum"]"
  565. return name
  566.  
  567. GetBirthStr: PROCEDURE
  568. parse arg gnum
  569. GETBIRTHPLACE gnum
  570. bstr = RESULT
  571. GETBIRTHDATE gnum
  572. bdat = RESULT
  573. if bdat ~= "" & bstr ~= "" then bstr = bstr||" "
  574. bstr = bstr||bdat
  575. if bstr ~= "" then bstr = ", b: "||bstr
  576. return bstr
  577.  
  578. GetDeathStr: PROCEDURE
  579. parse arg gnum
  580. GETDEATHPLACE gnum
  581. dstr = RESULT
  582. GETDEATHDATE gnum
  583. ddat = RESULT
  584. if ddat ~= "" & dstr ~= "" then dstr = dstr||" "
  585. dstr = dstr||ddat
  586. if dstr ~= "" then dstr = ", d: "||dstr
  587. return dstr
  588.  
  589. GetMarriages: PROCEDURE EXPOSE useirn
  590. parse arg irn
  591. mstr = ""
  592. GETMARRIAGE irn 0
  593. mf = RESULT
  594. EXISTFAMILY mf
  595. if RESULT = 'YES' then do
  596.   mtrue = 1
  597.   GETMARRIAGE irn 1
  598.   m2 = RESULT
  599.   EXISTFAMILY m2
  600.   if RESULT = 'YES' then mset = 1
  601.   else mset = 0
  602. end
  603. else
  604.   mtrue = 0  
  605. mnum = 0
  606. do while mtrue
  607.   m1 = GetMarriageStr(mf)
  608.   if m1 ~= "" then m1  = m1||' '
  609.   ptn = GetPartnerIRN(mf, irn)
  610.   m1 = m1||GetPersonStr(ptn)
  611.  
  612.   if mset then mstr = ", m("||mnum||"): "||m1
  613.   else mstr = ", m: "||m1
  614.  
  615.   mnum = mnum + 1    
  616.   GETMARRIAGE irn mnum
  617.   mf = RESULT
  618.   EXISTFAMILY mf
  619.   if RESULT ~= 'YES' then mtrue = 0
  620. end
  621. return mstr
  622.  
  623. GetMarriageStr: PROCEDURE
  624. parse arg mf
  625. GETMARRYPLACE mf
  626. mstr = RESULT
  627. GETMARRYDATE mf
  628. mdat = RESULT
  629. if mdat ~= "" & mstr ~= "" then mstr = mstr||" "
  630. mstr = mstr||mdat
  631. return mstr
  632.  
  633. GetParentsIRN: PROCEDURE EXPOSE GENTREE.
  634. parse arg fnum, ct, ct1
  635. fath = 0; moth = 0
  636. GETSPOUSE fnum
  637. sps = RESULT
  638. EXISTPERSON sps
  639. if RESULT = 'YES' then do
  640.   GETSEX sps
  641.   if RESULT = 'M' then
  642.     fath = sps
  643.   else moth = sps
  644. end
  645. GETPRINCIPAL fnum
  646. prn = RESULT
  647. /* If there are two mothers, or two fathers, then name the principal
  648.  * as 'father' and the spouse as 'mother'
  649.  */
  650. EXISTPERSON prn
  651. if RESULT = 'YES' then do
  652.   GETSEX prn
  653.   if RESULT = 'M' then do
  654.     if fath ~= 0 then
  655.       moth = sps
  656.     fath = prn
  657.   end
  658.   else if moth ~= 0 then
  659.     fath = prn
  660.   else
  661.     moth = prn
  662. end
  663. GENTREE.ct = fath
  664. GENTREE.ct1 = moth
  665. return 0
  666.  
  667. GetPartnerIRN: PROCEDURE
  668. parse arg fnum, inum
  669. GETPRINCIPAL fnum
  670. prn = RESULT
  671. GETSPOUSE fnum
  672. sps = RESULT
  673. if inum = prn then pnum = sps
  674. else if inum = sps then pnum = prn
  675. else pnum = 0
  676. return pnum
  677.  
  678. CheckAnswer: PROCEDURE EXPOSE outp prtdev usereq
  679. parse arg str
  680. str = left(str, 1)
  681. if ~DATATYPE(str, 'w') then
  682.   TermError("Arg(1): not a valid option number.")
  683. if str < 1 | str > 4 then
  684.   TermError("Arg(1): not a valid option number.")
  685. return  str
  686.  
  687. CheckIRN: PROCEDURE EXPOSE outp prtdev usereq
  688. parse arg str
  689. if ~DATATYPE(str, 'w') then
  690.   TermError("Arg(2): not a valid IRN..")
  691. return str
  692.  
  693. Tell: PROCEDURE EXPOSE outp
  694. parse arg str
  695. if outp then
  696.   writeln(stdout, str)
  697. return 0
  698.  
  699. TellNN: PROCEDURE EXPOSE outp
  700. /* Tell, No Newline */
  701. parse arg str
  702. if outp then
  703.   writech(stdout, str)
  704. return 0
  705.  
  706. TermError: PROCEDURE EXPOSE outp prtdev usereq PSCR
  707. parse arg str
  708. /* If you turned off stdout, no error messages will be shown! */
  709. if usereq then
  710.   rtezrequest(str,'E_xit','PrintDescendant Message:','rt_pubscrname = '||PSCR)
  711. else do
  712.   Tell(str || '0A'x)
  713. end
  714. close(prtdev)
  715. EXIT
  716.  
  717. /* Let's make sure you get a nice message when you turn off the printer :-) */
  718.  
  719. IOERR:
  720.   bline = SIGL
  721.   say "I/O error #"||RC||" detected in line "||bline||":"
  722.   say sourceline(bline)
  723.   EXIT
  724.